home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
akcl1615.lha
/
lsp
/
debug.lsp
< prev
next >
Wrap
Text File
|
1991-02-18
|
24KB
|
796 lines
;;Copyright William F. Schelter 1990, All Rights Reserved
(In-package "SYSTEM")
(import 'sloop::sloop)
(eval-when (compile eval)
(proclaim '(optimize (safety 2) (space 3)))
(defmacro f (op &rest args)
`(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
(defmacro fb (op &rest args)
`(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
)
;;; Some debugging features:
;;; Search-stack :
;;; (:s "cal") or (:s 'cal) searches the stack for a frame whose function or
;;; special form has a name containing "cal", moves there to display the local
;;; data.
;;;
;;; Break-locals :
;;; :bl displays the args and locals of the current function.
;;; (:bl 4) does this for 4 functions.
;;;
;;; (si:loc i) accesses the local(i): slot.
;;; the *print-level* and *print-depth* are bound to *debug-print-level*
;;; Note you must have space < 3 in your optimize proclamation, in order for
;;; the local variable names to be saved by the compiler.
;;; With BSD You may also use the function write-debug-symbols to
;;; obtain an object file with the correct symbol information for using a
;;; c debugger, on translated lisp code. You should have used the :debug
;;; t keyword when compiling the file.
;;; To Do: add setf method for si:loc.
;;; add restart capability from various spots on the stack.
(defun show-break-variables (&optional (n 1))
(loop
;(break-current)
(dolist (v (reverse(car *break-env*)))
(format *debug-io* "~%~9a: ~s" (car v) (second v)))
(or (fb > (incf n -1) 0) (return (values)))
(break-previous)
))
(defun show-environment (ihs)
(let ((lis (vs (ihs-vs ihs))))
(if (listp lis)
(dolist (v (reverse (vs (ihs-vs ihs))))
(format *debug-io* "~%~9a: ~s" (car v) (second v))))))
(putprop :a 'show-break-variables 'break-command)
;;make hack in compiler to remember the local variable names for the
;;vs variables and associate it with the function name
(defun search-stack (sym &aux string)
(setq string (cond((symbolp sym)(symbol-name sym))
(t sym)))
(sloop
for ihs downfrom (ihs-top) above 2
for fun = (ihs-fun ihs) with name
do
(cond ((compiled-function-p fun)
(setq name (compiled-function-name fun)))
((symbolp fun ) (setq name fun))
((and (listp fun)
(member (car fun) '(lambda lambda-block)))
(setq name (second fun)))
(t (setq name '||)))
when (search string (symbol-name name) :test 'equal)
do (return (progn (break-go ihs)(terpri) (break-locals)))
finally (format *debug-io* "~%Search for ~a failed" string)
))
(defvar *debug-print-level* 3)
(defun break-locals (&optional (n 1)
&aux (ihs *current-ihs*)
(base (ihs-vs ihs))
(*print-level* *debug-print-level*)
*print-circle*
(*print-length* *debug-print-level*)
(current-ihs *current-ihs*)
(fun (ihs-fun ihs)) name args)
(cond ((fb > n 1)
(sloop for i below n
for ihs downfrom current-ihs above 2
do (let ((*current-ihs* ihs))
(break-locals) (terpri)(terpri)
)))
(t
(cond ((compiled-function-p fun)
(setq name (compiled-function-name fun)))
(t (setq name fun)))
(if (symbolp name)(setq args (get name 'debug)))
(let ((next (ihs-vs (f + 1 *current-ihs*))))
(cond (next
(format *debug-io* ">> ~a():" name)
(cond ((symbolp name)
(sloop for i from base below next for j from 0
for u = nil
do
(cond ((member 0 args);;old debug info.
(setf u (getf args j)))
(t (setf u (nth j args))))
(cond (u
(format t
"~%Local~a(~a): ~a" j u (vs i)))
(t
(format *debug-io* "~%Local(~d): ~a"
j (vs i))))))
((listp name)
(show-environment ihs))
(t (format *debug-io* "~%Which case is this??")))))))))
(defun loc (&optional (n 0))
(let ((base (ihs-vs *current-ihs*)))
(unless (and (fb >= n 0)
(fb < n (f - (ihs-vs
(min (ihs-top) (f + 1 *current-ihs*)))
base)))
(error "Not in current function"))
(vs (f + n base))))
(putprop :bl 'break-locals 'break-command)
(putprop :s 'search-stack 'break-command)
(defvar *record-line-info* (make-hash-table :test 'eq))
(defvar *at-newline* nil)
(defvar *standard-readtable* *readtable*)
(defvar *line-info-readtable* (copy-readtable))
(defvar *left-parenthesis-reader* (get-macro-character #\( ))
(defvar *quotation-reader* (get-macro-character #\" ))
(defvar *stream-alist* nil)
(defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t))
(defvar *step-next* nil)
(defvar *last-dbl-break* nil)
#-akcl
(eval-when (compile eval load)
(defvar *places* '(|*mv0*| |*mv1*| |*mv2*| |*mv3*| |*mv4*| |*mv5*| |*mv6*| |*mv7*|
|*mv8*| |*mv9*|))
(defmacro set-mv (i val) `(setf ,(nth i *places*) ,val))
(defmacro mv-ref (i) (nth i *places*))
)
(defmacro mv-setq (lis form)
`(prog1 (setf ,(car lis) ,form)
,@ (do ((v (cdr lis) (cdr v))
(i 0 (1+ i))
(res))
((null v)(reverse res))
(push `(setf ,(car v) (mv-ref ,i)) res))))
(defmacro mv-values (&rest lis)
`(prog1 ,(car lis)
,@ (do ((v (cdr lis) (cdr v))
(i 0 (1+ i))
(res))
((null v)(reverse res))
(push `(set-mv ,i ,(car v)) res))))
;;start a lisp debugger loop. Exit it by using :step
(defun dbl ()
(break-level nil nil))
(defstruct instream stream (line 0 :type fixnum) stream-name)
(eval-when (eval compile)
(defstruct (bkpt (:type list)) form file file-line function)
)
(defun cleanup ()
(dolist (v *stream-alist*)
(if (closedp (instream-stream v))
(setq *stream-alist* (delete v *stream-alist*)))))
(defun get-instream (str)
(or (dolist (v *stream-alist*)
(cond ((eq str (instream-stream v))
(return v))))
(car (setq *stream-alist*
(cons (make-instream :stream str) *stream-alist*)))))
(defun newline (str ch) ch
(let ((in (get-instream str)))
(setf (instream-line in) (the fixnum (f + 1 (instream-line in)))))
;; if the next line begins with '(', then record all cons's eg arglist )
(setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t))
(values))
(defun quotation-reader (str ch)
(let ((tem (funcall *quotation-reader* str ch))
(instr (get-instream str)))
(incf (instream-line instr) (count #\newline tem))
tem))
(defvar *old-semicolon-reader* (get-macro-character #\;))
(defun new-semi-colon-reader (str ch)
(let ((in (get-instream str))
(next (peek-char nil str nil nil)))
(setf (instream-line in) (the fixnum (f + 1 (instream-line in))))
(cond ((eql next #\!)
(read-char str)
(let* ((*readtable* *standard-readtable*)
(command (read-from-string (read-line str nil nil))))
(cond ((and (consp command)
(eq (car command) :line)
(stringp (second command))
(typep (third command) 'fixnum))
(setf (instream-stream-name in) (second command))
(setf (instream-line in) (third command))))
))
(t (funcall *old-semicolon-reader* str ch)))
(setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t))
(values)))
(defun setup-lineinfo ()
(set-macro-character #\newline #'newline nil *line-info-readtable*)
(set-macro-character #\; #'new-semi-colon-reader nil *line-info-readtable*)
(set-macro-character #\( 'left-parenthesis-reader nil *line-info-readtable*)
(set-macro-character #\" 'quotation-reader nil *line-info-readtable*)
)
(defun nload (file &rest args )
(clrhash *record-line-info*)
(cleanup)
(setq file (truename file))
(setup-lineinfo)
(let ((*readtable* *line-info-readtable*))
(apply 'load file args)))
(eval-when (compile eval)
(defmacro break-data (name line) `(cons ,name ,line))
)
(defun left-parenthesis-reader (str ch &aux line(flag *at-newline*))
(if (eq *at-newline* t) (setq *at-newline* nil))
(when flag
(setq flag (get-instream str))
(setq line (instream-line flag))
)
(let ((tem (funcall *left-parenthesis-reader* str ch)))
(when flag
(setf (gethash tem *record-line-info*)
(break-data (instream-name flag)
line)))
tem))
(defvar *fun-array* (make-array 50 :fill-pointer 0 :adjustable t))
(defun walk-through (body &aux tem)
(tagbody
top
(cond ((consp body)
(when (setq tem (gethash body *record-line-info*))
;; lines beginning with ((< u v)..)
;; aren't eval'd but are part of a special form
(cond ((and (consp (car body))
(not (eq (caar body) 'lambda)))
(remhash body *record-line-info*)
(setf (gethash (car body) *record-line-info*)
tem))
(t (vector-push-extend (cons tem body) *fun-array*))))
(walk-through (car body))
(setq body (cdr body))
(go top))
(t nil))))
(defun compiler::compiler-def-hook (name body &aux (ar *fun-array*)
(min most-positive-fixnum)
(max -1))
(declare (fixnum min max))
;; (cond ((and (boundp '*do-it*)
;; (eq (car body) 'lambda-block))
;; (setf (cdr body) (cdr (walk-top body)))))
(cond ((atom body)
(remprop name 'line-info))
((eq *readtable* *line-info-readtable*)
(setf (fill-pointer *fun-array*) 0)
(walk-through body)
(dotimes (i (length ar))
(declare (fixnum i))
(let ((n (cdar (aref ar i))))
(declare (fixnum n))
(if (fb > n max) (setf max n))
(if (fb < n min) (setf min n))))
(cond ((fb > (length *fun-array*) 0)
(let ((new (make-array (f + (f - max min) 2)
:initial-element :blank-line))
(old-info (get name 'line-info)))
(setf (aref new 0)
(cons (caar (aref ar 0)) min))
(setq min (f - min 1))
(dotimes (i (length ar))
(let ((y (aref ar i)))
(setf (aref new (f - (cdar y) min))
(cdr y))))
(setf (get name 'line-info) new)
(when
old-info
(let ((tem (get name 'break-points))
(old-begin (cdr (aref old-info 0))))
(dolist (bptno tem)
(let* ((bpt (aref *break-points* bptno))
(fun (bkpt-function bpt))
(li (f - (bkpt-file-line bpt) old-begin)))
(setf (aref *break-points* bptno)
(make-break-point fun new li))))))))
(t (let ((tem (get name 'break-points)))
(iterate-over-bkpts tem :delete)))))))
(defun instream-name (instr)
(or (instream-stream-name instr)
(stream-name (instream-stream instr))))
(eval-when (eval)
(defun stream-name (str) (namestring (pathname str)))
)
(clines "static object stream_name(str) object str;{return str->sm.sm_object1; }")
(defentry stream-name (object) (object "stream_name"))
(clines "static object closedp(str) object str;{return (str->sm.sm_fp==0 ? Ct :Cnil); }")
(defentry closedp (object) (object "closedp"))
(defun find-line-in-fun (form env fun counter &aux tem)
(setq tem (get fun 'line-info))
(if tem
(let ((ar tem))
(declare (type (array (t)) ar))
(when ar
(dotimes
(i (length ar))
(cond ((eq form (aref ar i))
(when counter
(decf (car counter))
(cond ((fb > (car counter) 0)
;silent
(return-from find-line-in-fun :break))))
(break-level
(setq *last-dbl-break* (make-break-point fun ar i)) env
)
(return-from find-line-in-fun :break))))))))
;; get the most recent function on the stack with step info.
(defun current-step-fun ( &optional (ihs (ihs-top)) )
(do ((i (1- ihs) (f - i 1)))
((fb <= i 0))
(let ((na (ihs-fname i)))
(if (get na 'line-info) (return na)))))
(defun init-break-points ()
(setf (fill-pointer *break-point-vector*) 0)
(setf *break-points* *break-point-vector*))
(defun step-into (&optional (n 1))
;;FORM is the next form about to be evaluated.
(or *break-points* (init-break-points))
(setq *break-step* 'break-step-into)
:resume)
(defun step-next ( &optional (n 1))
(let ((fun (current-step-fun)))
(setq *step-next* (cons n fun))
(or *break-points* (init-break-points))
(setq *break-step* 'break-step-next)
:resume))
(defun maybe-break (form line-info fun env &aux pos)
(cond ((setq pos (position form line-info))
(setq *break-step* nil)
(or (> (length *break-points*) 0)
(setf *break-points* nil))
(break-level (make-break-point fun line-info pos) env)
t)))
;; These following functions, when they are the value of *break-step*
;; are invoked by an inner hook in eval. They may choose to stop
;; things.
(defun break-step-into (form env)
(let ((fun (current-step-fun)))
(let ((line-info (get fun 'line-info)))
(maybe-break form line-info fun env))))
(defun break-step-next (form env)
(let ((fun (current-step-fun)))
(cond ((eql (cdr *step-next*) fun)
(let ((line-info (get fun 'line-info)))
(maybe-break form line-info fun env))))))
(setf (get :next 'break-command) 'step-next)
(setf (get :step 'break-command) 'step-into)
(setf (get :loc 'break-command) 'loc)
(defun *break-points* (form env)
(let ((pos(position form *break-points* :key 'car)))
(format t "Bkpt ~a:" pos)
(break-level (aref *break-points* pos) env)))
(defun dwim (fun)
(dolist (v (list-all-packages))
(multiple-value-bind
(sym there)
(intern (symbol-name fun) v)
(cond ((get sym 'line-info)
(return-from dwim sym))
(t (or there (unintern sym))))))
(format t "~a has no line information" fun))
(defun break-function (fun &optional (li 1) absolute &aux fun1)
(let ((ar (get fun 'line-info)))
(when (null ar) (setq fun1 (dwim fun))
(if fun1 (return-from break-function
(break-function fun1 li absolute))))
(or (arrayp ar)(progn (format t "~%No line info for ~a" fun)
(return-from break-function nil)))
(let ((beg (cdr (aref ar 0))))
(if absolute (setq li (f - li beg)))
(or (and (fb >= li 1) (fb < li (length ar)))
(progn (format t "~%line out of bounds for ~a" fun))
(return-from break-function nil))
(if (eql li 1)
(let ((tem (symbol-function fun)))
(cond ((and (consp tem)
(eq (car tem) 'lambda-block)
(third tem))
(setq li 2)))))
(dotimes (i (f - (length ar) li))
(when (not (eq (aref ar i) :blank-line))
(show-break-point (insert-break-point
(make-break-point fun ar (f + li i))))
(return-from break-function (values))))
(format t "~%Beyond code for ~a "))))
(defun insert-break-point (bpt &aux at)
(or *break-points* (init-break-points))
(setq at (or (position nil *break-points*)
(prog1 (length *break-points*)
(vector-push-extend nil *break-points*)
)))
(let ((fun (bkpt-function bpt)))
(push at (get fun 'break-points)))
(setf (aref *break-points* at) bpt)
at)
(defun short-name (name)
(let ((Pos (position #\/ name :from-end t)))
(if pos (subseq name (f + 1 pos)) name)))
(defun show-break-point (n &aux disabled)
(let ((bpt (aref *break-points* n)))
(when bpt
(when (eq (car bpt) nil)
(setq disabled t)
(setq bpt (cdr bpt)))
(format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]"
n (short-name (second bpt))
(third bpt) disabled)
(let ((fun (fourth bpt)))
(format t "(line ~a of ~a)" (relative-line fun (nth 2 bpt))
fun
)))))
(defun iterate-over-bkpts (l action)
(dotimes (i (length *break-points*))
(if (or (member i l)
(null l))
(let ((tem (aref *break-points* i)))
(setf (aref *break-points* i)
(case action
(:delete
(if tem (setf (get (bkpt-function tem) 'break-points)
(delete i (get (bkpt-function tem) 'break-points))))
nil)
(:enable
(if (eq (car tem) nil) (cdr tem) nil))
(:disable
(if (and tem (not (eq (car tem) nil)))
(cons nil tem)
tem))
(:show
(when tem (show-break-point i)
(terpri))
tem
)))))))
(setf (get :info 'break-command)
'(lambda (type)
(case type
(:bkpt (iterate-over-bkpts nil :show))
(otherwise
(format t "usage: :info :bkpt -- show breakpoints")
))))
(setf (get :delete 'break-command)
'(lambda (&rest l) (iterate-over-bkpts l :delete)(values)))
(setf (get :disable 'break-command)
'(lambda (&rest l) (iterate-over-bkpts l :disable)(values)))
(setf (get :enable 'break-command)
'(lambda (&rest l) (iterate-over-bkpts l :enable)(values)))
(setf (get :break 'break-command)
'(lambda (&rest l)
(print l)
(cond (l
(apply 'si::break-function l))
(*last-dbl-break*
(let ((fun (nth 3 *last-dbl-break*)))
(si::break-function fun (nth 2 *last-dbl-break*) t))))))
(setf (get :fr 'break-command)
'(lambda (&rest l )
(dbl-up (or (car l) 0) *ihs-top*)
(values)))
(setf (get :up 'break-command)
'(lambda (&rest l )
(dbl-up (or (car l) 1) *current-ihs*)
(values)))
(setf (get :down 'break-command)
'(lambda (&rest l )
(dbl-up ( - (or (car l) 1)) *current-ihs*)
(values)))
;; in other common lisps this should be a string output stream.
(defvar *display-string*
(make-array 100 :element-type 'string-char :fill-pointer 0 :adjustable t))
(defun display-env (n env)
(do ((v (reverse env) (cdr v)))
((or (not (consp v)) (fb > (fill-pointer *display-string*) n)))
(or (and (consp (car v))
(listp (cdar v)))
(return))
(format *display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))
(defun apply-display-fun (display-fun n lis)
(let ((*print-length* *debug-print-level*)
(*print-level* *debug-print-level*)
(*print-pretty* nil)
(*PRINT-CASE* :downcase)
(*print-circle* t)
)
(setf (fill-pointer *display-string*) 0)
(format *display-string* "{")
(funcall display-fun n lis)
(when (fb > (fill-pointer *display-string*) n)
(setf (fill-pointer *display-string*) n)
(format *display-string* "..."))
(format *display-string* "}")
)
*display-string*
)
(setf (get :bt 'break-command) 'dbl-backtrace)
(setf (get '*break-points* 'dbl-invisible) t)
(defun get-line-of-form (form line-info)
(let ((pos (position form line-info)))
(if pos (f + pos (cdr (aref line-info 0))))))
(defun get-next-visible-fun (ihs)
(do ((j ihs (f - j 1)))
((fb < j *ihs-base*)
(mv-values nil j))
(let
((na (ihs-fname j)))
(cond ((special-form-p na))
((get na 'dbl-invisible))
((fboundp na)(return (mv-values na j)))))))
(defun dbl-what-frame (ihs &aux (j *ihs-top*) (i 0) na)
(declare (fixnum ihs j i))
(loop
(mv-setq (na j) (get-next-visible-fun j))
(cond ((fb <= j ihs) (return i)))
(setq i (f + i 1))
(setq j (f - j 1))))
(defun dbl-up (n ihs &aux m fun line file env )
(setq m (dbl-what-frame ihs))
(cond ((fb >= n 0)
(mv-setq (*current-ihs* n fun line file env)
(nth-stack-frame n ihs))
(set-env)
(print-stack-frame (f + m n) t *current-ihs* fun line file env))
(t (setq n (f + m n))
(or (fb >= n 0) (setq n 0))
(dbl-up n *ihs-top*))))
(dolist (v '( break-level universal-error-handler terminal-interrupt
break-level evalhook find-line-in-fun))
(setf (get v 'dbl-invisible) t))
(defun next-stack-frame (ihs &aux line-info li i k na)
(cond
((fb < ihs *ihs-base*) (mv-values nil nil nil nil nil ))
(t (let (fun)
;; next lower visible ihs
(mv-setq (fun i) (get-next-visible-fun ihs))
(setq na fun)
(cond
((and
(setq line-info (get fun 'line-info))
(do ((j (f + ihs 1) (f - j 1))
(form ))
((<= j i) nil)
(setq form (ihs-fun j))
(cond ((setq li (get-line-of-form (ihs-fun j) line-info))
(return-from next-stack-frame
(mv-values
i fun li
;; filename
(car (aref line-info 0))
;;environment
(list (vs (setq k (ihs-vs j)))
(vs (1+ k))
(vs (+ k 2)))
)))))))
((special-form-p na) nil)
((get na 'dbl-invisible))
((fboundp na)
(mv-values i na nil nil
(if (ihs-not-interpreted-env i)
nil
(let ((i (ihs-vs i)))
(list (vs i) (vs (1+ i)) (vs (f + i 2))))))))
))))
(defun nth-stack-frame (n &optional (ihs *ihs-top*)
&aux name line file env next)
(or (fb >= n 0) (setq n 0))
(dotimes (i (f + n 1))
(setq next (next-stack-frame ihs))
(cond (next
(mv-setq (ihs name line file env) next)
(setq ihs (f - next 1)))
(t (return (setq n (f - i 1))))))
(setq ihs (f + ihs 1) name (ihs-fname ihs))
(mv-values ihs n name line file env ))
(defun dbl-backtrace (&optional (m 1000) (ihs *ihs-top*) &aux fun file
line env (i 0))
(loop
(mv-setq (ihs fun line file env) (next-stack-frame ihs))
(or fun (return nil))
(print-stack-frame i nil ihs fun line file env)
(incf i)
(cond ((fb >= i m) (return (values))))
(setq ihs (f - ihs 1))
)
(values))
(defun display-compiled-env ( plength ihs &aux
(base (ihs-vs ihs))
(end (min (ihs-vs (1+ ihs)) (vs-top))))
(format *display-string* "")
(do ((i base )
(v (get (ihs-fname ihs) 'debug) (cdr v)))
((or (fb >= i end)(fb > (fill-pointer *display-string*) plength)))
(format *display-string* "~a~@[~d~]=~s~@[,~]"
(or (car v) 'loc) (if (not (car v)) (f - i base)) (vs i)
(fb < (setq i (f + i 1)) end)))
)
(defun computing-args-p (ihs)
;; When running interpreted we want a line like
;; (list joe jane) to get recorded in the invocation
;; history while joe and jane are being evaluated,
;; even though list has not yet been invoked. We put
;; it in the history, but with the previous lexical environment.
(and (consp (ihs-fun ihs))
(> ihs 3)
(not (member (car (ihs-fun ihs)) '(lambda-block lambda)))
;(<= (ihs-vs ihs) (ihs-vs (- ihs 1)))
)
)
(defun print-stack-frame (i auto-display ihs fun &optional line file env)
(when (and auto-display line)
(format *debug-io* "~a:~a:0:beg~%" file line))
(let ((computing-args (computing-args-p ihs)))
(format *debug-io* "~&#~d ~@[~a~] ~a ~@[~a~] " i
(and computing-args "Computing args for ")
fun
(if (not (ihs-not-interpreted-env ihs))
(apply-display-fun 'display-env 80
(car (vs (ihs-vs ihs))))
(apply-display-fun 'display-compiled-env 80 ihs)))
(if file (format *debug-io* "(~a line ~a)" file line))
(format *debug-io* "[ihs=~a]" ihs)
))
(defun make-break-point (fun ar i)
(list ;make-bkpt ;:form
(aref ar i)
;:file
(car (aref ar 0))
;:file-line
(f + (cdr (aref ar 0)) i)
;:function
fun)
)
(defun relative-line (fun l)
(let ((info (get fun 'line-info)))
(if info (f - l (cdr (aref info 0)))
0)))
(defvar *step-display* nil)
(defvar *null-io* (make-broadcast-stream))
;; should really use serror to evaluate this inside.
;; rather than just quietening it. It prints a long stack
;; which is time consuming.
(defun safe-eval (form env &aux *break-enable*)
(let ((*error-output* *null-io*)
(*debug-io* *null-io*))
(cond ((symbolp form)
(unless (or (boundp form)
(assoc form (car env)))
(return-from safe-eval :<error>))))
(multiple-value-bind (er val)
(si::error-set
`(evalhook ',form nil nil ',env))
(if er :<error> val))))
(defvar *no-prompt* nil)
(defun set-back (at env &aux (i *current-ihs*))
(setq *no-prompt* nil)
(setq *current-ihs* i)
(cond (env (setq *break-env* env))
(t (list (vs (ihs-vs i)))))
(when at
(format *debug-io* "~a:~a:0:beg~%" (second at) (third at))
(format *debug-io* "(~a line ~a) "
(second at) (third at))
)
(dolist (v *step-display*)
(let ((res (safe-eval v env)))
(or (eq res :<error>)
(format t "(~s=~s)" v res)))))
(eval-when (load eval)
(pushnew :sdebug *features* )
;(use-fast-links nil)
)